- AGTXRHRN ; IHS/ASDS/EFG - utility for investigating valid Official Registration FAC:HRN ;
- ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
- ;
- ;****************************************************************
- ;
- ;This is a utility for investigating Official Registration Fac:HRNs
- ;NEEDS DFN
- ;given AGRSITE it will test/return AGRHRN=0 OR = HRN if it is valid
- ;not given AGRSITE it will return an AGRSITE
- ;and AGRHRN =0 if none or with valid entries
- ;
- ;****************************************************************
- ;
- I $G(AGRSITE) D G END
- . D HRN
- . S:'$D(^AGFAC("AC",AGRSITE)) AGRHRN=0
- S AGRSITE=0
- F S AGRSITE=$O(^AGFAC("AC",AGRSITE)) Q:AGRSITE'>0 D HRN I $G(AGRHRN) G END ;--->
- G END
- ;****************************************************************
- HRN ;EP -
- ;find valid HRN for AGRSITE,DFN
- TSTHRN ;
- ;test HRN validity uses AGRSITE returns AGRHRN if found and valid
- S AGRHRN=0
- Q:'$D(^AUPNPAT(DFN,41,AGRSITE,0)) ;no data
- S X=$P(^AUPNPAT(DFN,41,AGRSITE,0),U,2)
- S (DA,D1)=AGRSITE
- S (DA(1),D0)=DFN
- X $P(^DD(9000001.41,.02,0),U,5,99)
- K DA,D1,D0
- Q:'$G(X) ;fails input test
- S AGRHRN=$P(^AUPNPAT(DFN,41,AGRSITE,0),"^",2)
- S AGRHRN("DT")=$P(^AUPNPAT(DFN,41,AGRSITE,0),U,3)
- S AGRHRN("S")=$P(^AUPNPAT(DFN,41,AGRSITE,0),U,5)
- I (AGRHRN'?1.6N)!(AGRHRN("S")="M") S AGRHRN=0 Q ;fails pattern or merge
- I '$G(AGRHRN("DT")) Q ;passes, NO DELETES,INACTIVE
- I AGRHRN("S")="I" Q ;Inactivated records pass
- S AGRHRN=0 ;all deletes fail .. calling routine must handle error
- Q
- ;****************************************************************
- END ;
- K AGRHRN("DT"),AGRHRN("S"),X,X1,X2
- Q
- AGTXRHRN ; IHS/ASDS/EFG - utility for investigating valid Official Registration FAC:HRN ;
- +1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
- +2 ;
- +3 ;****************************************************************
- +4 ;
- +5 ;This is a utility for investigating Official Registration Fac:HRNs
- +6 ;NEEDS DFN
- +7 ;given AGRSITE it will test/return AGRHRN=0 OR = HRN if it is valid
- +8 ;not given AGRSITE it will return an AGRSITE
- +9 ;and AGRHRN =0 if none or with valid entries
- +10 ;
- +11 ;****************************************************************
- +12 ;
- +13 IF $GET(AGRSITE)
- Begin DoDot:1
- +14 DO HRN
- +15 IF '$DATA(^AGFAC("AC",AGRSITE))
- SET AGRHRN=0
- End DoDot:1
- GOTO END
- +16 SET AGRSITE=0
- +17 ;--->
- FOR
- SET AGRSITE=$ORDER(^AGFAC("AC",AGRSITE))
- IF AGRSITE'>0
- QUIT
- DO HRN
- IF $GET(AGRHRN)
- GOTO END
- +18 GOTO END
- +19 ;****************************************************************
- HRN ;EP -
- +1 ;find valid HRN for AGRSITE,DFN
- TSTHRN ;
- +1 ;test HRN validity uses AGRSITE returns AGRHRN if found and valid
- +2 SET AGRHRN=0
- +3 ;no data
- IF '$DATA(^AUPNPAT(DFN,41,AGRSITE,0))
- QUIT
- +4 SET X=$PIECE(^AUPNPAT(DFN,41,AGRSITE,0),U,2)
- +5 SET (DA,D1)=AGRSITE
- +6 SET (DA(1),D0)=DFN
- +7 XECUTE $PIECE(^DD(9000001.41,.02,0),U,5,99)
- +8 KILL DA,D1,D0
- +9 ;fails input test
- IF '$GET(X)
- QUIT
- +10 SET AGRHRN=$PIECE(^AUPNPAT(DFN,41,AGRSITE,0),"^",2)
- +11 SET AGRHRN("DT")=$PIECE(^AUPNPAT(DFN,41,AGRSITE,0),U,3)
- +12 SET AGRHRN("S")=$PIECE(^AUPNPAT(DFN,41,AGRSITE,0),U,5)
- +13 ;fails pattern or merge
- IF (AGRHRN'?1.6N)!(AGRHRN("S")="M")
- SET AGRHRN=0
- QUIT
- +14 ;passes, NO DELETES,INACTIVE
- IF '$GET(AGRHRN("DT"))
- QUIT
- +15 ;Inactivated records pass
- IF AGRHRN("S")="I"
- QUIT
- +16 ;all deletes fail .. calling routine must handle error
- SET AGRHRN=0
- +17 QUIT
- +18 ;****************************************************************
- END ;
- +1 KILL AGRHRN("DT"),AGRHRN("S"),X,X1,X2
- +2 QUIT
