source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRXOR.m@ 1270

IMRXOR ;ISC-SF/JLI,HCIOFO/FT-XOR ENCRYPTION FOR IMR POINTERS ;5/22/95  12:12
 ;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
 I '$D(^XUSEC("IMRA",DUZ)) S IMRLOC="IMRXOR" D ACESSERR^IMRERR,H^XUS
EN1 ; entry point from post-init
 I '$D(IMRSTN) D IMROPN Q:'$D(IMRSTN)
XOR S IMRXORZ="" I X'?1N.N S IMRXORZ=X,X="" F IMRXORY=0:0 S IMRXORX2=$E(IMRXORZ) Q:IMRXORX2'?1N  S X=X_IMRXORX2,IMRXORZ=$E(IMRXORZ,2,99)
 S (IMRXORX2,IMRXORX4)=+X,(IMRXORA,IMRXORB)=0,IMRXORN=7
B17 S IMRXORM="0000^0001^0010^0011^0100^0101^0110^0111^1000^1001^1010^1011^1100^1101^1110^1111^"
 S X=0 F IMRXORI=0:1 S IMRXOR2=IMRXORX2#16,IMRXORX2=IMRXORX2\16 D XOR1 S IMRXORB=IMRXORB+IMRXOR2 I (IMRXORB=IMRXORX4)&(IMRXORI>IMRXORN) Q
 S X=X_IMRXORZ
 K IMRXOR2,IMRXOR3,IMRXOR4,IMRXORM,IMRXORI,IMRXORA,IMRXORB,IMRXORJ,IMRXORX,IMRXORX2,IMRXORX4,IMRXORZ,IMRLOC,IMRXORN,IMRXORY
 Q
XOR1 ;
 S IMRXOR3="1101",IMRXOR4=$P(IMRXORM,"^",IMRXOR2+1),IMRXORX="" F IMRXORJ=1:1:4 S IMRXORX=IMRXORX_($E(IMRXOR3,IMRXORJ)'=$E(IMRXOR4,IMRXORJ))
 S IMRXORX=$F(IMRXORM,IMRXORX),IMRXORX=IMRXORX/5-1
 I IMRXORI>0 F IMRXORJ=1:1:IMRXORI S IMRXORX=IMRXORX*16,IMRXOR2=IMRXOR2*16
 S X=X+IMRXORX
 Q
IMROPN ;
 I $D(^IMR(158.9,1,0)) S IMRSTN=$P(^(0),U),IMRSTN=$P(^DIC(4,+IMRSTN,99),U) Q
 Q
SPTNAME ; set logic for Activate 'Name' Pointer field
 ; called from ^DD(158.9,.07,1,1,1)
 Q:+$P($G(^IMR(158.9,D0,0)),U,7)=0
 F IMRI=0:0 S IMRI=$O(^IMR(158,IMRI)) Q:IMRI'>0  S X=+^(IMRI,0) D IMRXOR I $D(^DPT(X,0)) S ^IMR(158,IMRI,103)=X,^IMR(158,"BP",X,IMRI)=""
 K IMRI
 Q
KPTNAME ; kill logic for Activate 'Name' Pointer field
 ; called from ^DD(158.9,.07,1,1,2)
 F IMRI=0:0 S IMRI=$O(^IMR(158,IMRI)) Q:IMRI'>0  K ^(IMRI,103)
 K ^IMR(158,"BP"),IMRI
 Q
A17 ;
 S IMRXORZ="" I X'?1N.N S IMRXORZ=X,X="" F IMRXORY=0:0 S IMRXORX2=$E(IMRXORZ) Q:IMRXORX2'?1N  S X=X_IMRXORX2,IMRXORZ=$E(IMRXORZ,2,99)
 S (IMRXORX2,IMRXORX4)=+X,(IMRXORA,IMRXORB)=0,IMRXORN=4
 G B17